module Salsa.Interpreter where
import Salsa.Primitives
import Salsa.Types
import Salsa.Parser
import Control.Monad.Error
import System.Directory
import IO

runRepl :: IO ()
runRepl = primitiveEnv >>=
          until_ ((== "(quit)") . show) (readPrompt "SALSA!> ") . evalAndPrint

evalAndPrint :: Env -> Exp -> IO ()
evalAndPrint env x = (showIOThrows $ liftM show $ catchError (eval env x) (return . String . show)) >>= putStrLn

readPrompt :: String -> IO Exp
readPrompt prompt = 
    putFlush prompt >> loop ""
    where loop strAcc =
              do newAttempt <- getLine
                 let str = strAcc ++ " " ++ newAttempt 
                   in case readExp str of
                        Left err -> loop str
                        Right val -> return val

hEval :: Env -> Handle -> String ->IOThrowsError Exp
hEval env h name =
    do conts <- (liftIO $ hGetContents h) 
       exps <- (liftThrows $ readExps conts)
       values <- mapM (eval env) exps
       return $ last values
--     loop "" 0 ExpectingLine
--     where loop :: String -> Int -> InterpreterState -> IOThrowsError Exp
--           loop strAcc line state =    
--               do newAttempt <- readHelper h
--                  if (newAttempt == "EOF" && state == ExpectingLine)
--                    then throwError $ UnexpectedEOF name (1 + line) strAcc 
--                    else let str = strAcc ++ " " ++ newAttempt
--                          in case readExps str of
--                               Left err -> loop str (1 + line) ExpectingLine
--                               Right expr -> do exec <- liftIO $ runErrorT $ evalString env str
--                                                case exec of
--                                                  Left err -> do liftIO $ putStrLn $ "Error at line " ++ show (1 + line) ++ " in: " ++ str
--                                                                 throwError err
--                                                  Right val -> do newStr <- readHelper h
--                                                                  if newStr == "EOF"
--                                                                   then return val
--                                                                   else loop newStr (2 + line) EvaledSuccessfully
          
--           readHelper h = liftIO $ hGetLine h `catch` (\_ -> return "EOF")

runFile :: FilePath -> IO ()
runFile path = 
    do env <- primitiveEnv
       h <- openFile path ReadMode
       exec <- runErrorT $ hEval env h path
       case exec of 
         Right val -> putStrLn $ show val
         Left err -> putStrLn $ show err
       

evalString :: Env -> String -> IOThrowsError Exp
evalString env str = do xs <- liftThrows $ readExps str
                        values <- mapM (eval env) xs
                        return $ last values

evalStr2Str :: Env -> String -> IO String
evalStr2Str env str = do exec <- liftIO $ runErrorT $ evalString env str
                         case exec of 
                           Left err -> return $ show err
                           Right val -> return $ show val

primitiveEnv :: IO Env
primitiveEnv = 
    do val <- runErrorT loadEnv
       case val of
         Left err -> do putStrLn $ "Error while loading SALSA!: " ++ (show err)
                        nullEnv
         Right env -> return env

loadEnv :: IOThrowsError Env
loadEnv = 
    do env <- liftIO $ nullEnv
       liftIO $ bindVars env $ map (makePrimFun Primitive) primitives ++ map (makePrimFun IOFun) ioPrimitives
       h <- liftIO $ openFile "Salsa/Standard.sl" ReadMode
       catchError (hEval env h "Salsa/Standard.sl") (return . String . show)
       return env
    where makePrimFun constructor (name, f) = (name, constructor f)

eval :: Env -> Exp -> IOThrowsError Exp
eval env x@(String _) = return x
eval env x@(Integer _) = return x
eval env x@(Bool _) = return x
eval env form@(List ((Symbol "lambda"):formals:body)) = 
    if validFormals formals 
    then return $ Lambda formals body env
    else throwError $ BadSpecialForm "Invalid formals in lambda definition: " form
eval env lambda@(Lambda _ _ _) = return lambda 
eval env (Symbol name) = getVar env name
eval env (List [Symbol "quote", x]) = return x
eval env form@(List ((Symbol "apply"):f:args)) = 
    do fun <- eval env f
       if isFun fun
        then mapM (eval env) args >>= apply fun
        else throwError $ BadSpecialForm "Unrecognized special form. First argument to apply must be a procedure, found" form
eval env (List [Symbol "if", pred, cons, alt]) =
    do result <- eval env pred
       case result of
         Bool False -> eval env alt
         otherwise -> eval  env cons
eval env (List ((Symbol "or"):args)) = evalOr env args
eval env (List ((Symbol "and"):args)) = evalAnd env args
eval env (List ((Symbol "case"):rest)) = evalCase env rest
eval env form@(List ((Symbol "do"):exps)) = 
    if null exps 
    then throwError $ BadSpecialForm "The body of a do expression must contain at least one expression, found" form
    else liftM last $ mapM (eval env) exps
eval env (List [Symbol "set!", Symbol name, form]) = 
    eval env form >>= setVar env name
eval env (List [Symbol "set-car", maybePair, form]) =
    do pair <- eval env maybePair
       case pair of
         DotList (x:xs) tail -> eval env form >>= 
                                \val -> return $ DotList (val:xs) tail
         List  (x:xs) -> eval env form >>= \val -> return $ List (val:xs)
         otherwise -> throwError $ BadSpecialForm "set-car expects a pair or list, found" maybePair
eval env (List [Symbol "set-cdr", maybePair, form]) =
    do pair <- eval env maybePair
       case pair of
         DotList head _ -> do val <- eval env form 
                              case val of 
                                List xs -> return $ List $ head ++ xs
                                otherwise -> return $ DotList head val
         List  (x:xs) -> do val <- eval env form 
                            case val of
                              List xs' -> return $ List (x:xs')
                              otherwise -> return $ DotList [x] val
         otherwise -> throwError $ BadSpecialForm "set-cdr expects a pair or list, found" maybePair
eval env (List [Symbol "define", Symbol name, form]) = 
    eval env form >>= liftIO . defineVar env name
eval env def@(List ((Symbol "define"):rest)) =
    (liftThrows $ fd2sd def env) >>= eval env >> (eval env $ (String . show) def)
eval env (List [Symbol "load", String name]) = 
    whenIsFile name 
               ((liftIO $ openFile name ReadMode) >>= (\h ->  hEval env h name))
               (return $ String $ "File " ++ name ++ " not found")
eval env (List [Symbol "forward", String name]) = 
    do String path <- getVar env "root"
       let realName = if take 1 name == "/" then name else (path ++ name)
           continue = do contents <- liftIO $ readFile realName
                         exec <- toHTML env contents
                         return $ String exec
           alternative = throwError $ MamboError $ "File " ++ realName ++ " not found."           
         in do whenIsFile realName continue alternative 
                     
eval env form@(List (f:args)) = 
    do fun <- eval env f
       if isFun fun
         then mapM (eval env) args >>= apply fun 
         else throwError $ BadSpecialForm "Unrecognized special form. Expecting a valid combination, found" form
eval env badForm =  badFormError badForm
badFormError badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm

whenIsFile name block alternative = 
   do isDirectory <- liftIO $ doesDirectoryExist name
      fileExists <- liftIO $ doesFileExist name
      if (not isDirectory && fileExists)
       then block
       else alternative

evalOr :: Env -> [Exp] -> IOThrowsError Exp
evalOr env [] = return $ Bool False
evalOr env (x:xs) = 
    do val <- eval env x
       if isFalse val then evalOr env xs else return val

evalAnd :: Env -> [Exp] -> IOThrowsError Exp
evalAnd env [] = return $ Bool True
evalAnd env (x:[]) = 
    do val <- eval env x
       if not $ isFalse val then return val else return $ Bool False
evalAnd env (x:xs) = 
    do val <- eval env x
       if not $ isFalse val then evalAnd env xs else return val

evalCase env cases@(c:cs) = 
    loop cases where 
        loop :: [Exp] -> IOThrowsError Exp
        loop ([List [Symbol "else",form]]) = eval env form
        loop ((List [cond, cons]):cases) = do val <- eval env cond
                                              case val of
                                                Bool False -> if null cases 
                                                              then return $ List []
                                                              else loop cases
                                                otherwise -> eval env cons
        loop badForm = throwError $ BadSpecialForm "Unrecognized special form in case analysis" $ List badForm
evalCase _ badForm = throwError $ BadSpecialForm "Unrecognized special form in case analysis" $ List badForm

apply :: Exp -> [Exp] -> IOThrowsError Exp
apply (Primitive f) args =  liftThrows $ f args
apply l@(Lambda (List formals) body closure) args =
    if len formals /= len args
    then throwError $ NumArgs (len formals) args (show l)
    else do nEnv <- liftIO $ newEnv closure
            liftIO $ bindVars nEnv $ zipWith makeNameValuePair formals args
            liftM last $ mapM (eval nEnv) body
apply (Lambda (Symbol sym) body closure) args =
    do nEnv <- liftIO $ newEnv closure
       liftIO $ defineVar nEnv sym (List args)
       values <- mapM (eval nEnv) body
       return $ last values
apply (Lambda (DotList list (Symbol name)) body closure) args = 
    if len args < len list
    then throwError $ AtLeastNumArgs (len list) args ""
    else do nEnv <- liftIO $ newEnv closure
            liftIO $ bindVars nEnv $ zipWith makeNameValuePair list args
            liftIO $ defineVar nEnv name $ List $ drop (length list) args
            values <- mapM (eval nEnv) body
            return $ last values
apply (IOFun fun) args = fun args

len = toInteger . length
makeNameValuePair (Symbol formal) arg = (formal,arg)

bindVars :: Env -> [(String, Exp)] -> IO ()
bindVars env bindings = 
    do mapM (uncurry (defineVar env)) bindings
       return ()

defineVar :: Env -> String -> Exp -> IO Exp
defineVar env name value = 
     do updateEnv env name value
        return value

setVar :: Env -> String -> Exp -> IOThrowsError Exp
setVar env name value =
    do bound <- liftIO $ isBound env name
       if bound then liftIO 
              $ defineVar env name value else throwError 
              $ UnboundVar "Getting and unbound variable" name
           
getVar :: Env -> String -> IOThrowsError Exp
getVar env name = 
    do defined <- liftIO $ lookupEnv env name
       maybe (tryNextEnv env)
             return
             defined
           where tryNextEnv env = 
                     case nextEnv env of
                       Nil -> throwError $ UnboundVar "Getting an unbound variable" name
                       Scope nEnv -> getVar nEnv name
                  
isBound :: Env -> String -> IO Bool
isBound env name = lookupEnv env name >>=
                   return .  maybe (False) 
                   (const $ True)

until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
until_ pred prompt action = do 
  result <- prompt
  if pred result 
     then return ()
     else action result >> until_ pred prompt action

putFlush :: String -> IO ()
putFlush str = putStr str >> hFlush stdout


-------------------------------
-- Used to be Celia code
-------------------------------

-- Takes the contents of a Merengue  file 
-- and interprets the embedded SALSA! code
-- returning a string containing the html code
toHTML :: Env -> String -> IOThrowsError String
toHTML env str = loop env str "" 
    where loop :: Env -> String -> String -> IOThrowsError String
          loop env ('<':'s':'p':'i':'l':'l':'>':xs) acc = 
              do tup <- liftThrows $ stripTag Spill xs
                 expr <- liftIO $  runErrorT $ evalString env (fst tup) 
                 case expr of
                   Left err -> throwError err
                   Right val -> loop env (snd tup) (acc ++ prettyPrint val)
          loop env ('<':'s':'e':'r':'v':'e':'>':xs) acc = 
              do tup <- liftThrows $ stripTag Serve xs
                 liftIO $ runErrorT $ evalString env (fst tup) 
                 loop env (snd tup) acc
          loop _ [] acc = do hdrs <- liftIO $ getHeaders env
                             return ("\r\n" ++ hdrs ++ "\n\n" ++ acc)
          loop env str acc = loop env (drop 1 str) (acc ++ take 1 str)

prettyPrint (String s) = s
prettyPrint other = show other

getHeaders env = do val <- runErrorT $ getVar env "hdrs"
                    case val of
                      Left err -> return ""
                      Right (List hdrs) -> return $ concatMap toHttpHdr hdrs
                      Right other -> return ""

toHttpHdr (DotList [k] v) = (prettyPrint k) ++ ": " ++ (prettyPrint v) ++ "\r\n"
toHttpHdr other = ""

-- Takes the rest of the file, starting from the end of the tags <spill> or <serve>
-- and returns a tuple containing the string representing the salsa code 
-- and the rest of the HTML file:  (salsaCode,restOfHTML)
stripTag :: Tag -> String -> ThrowsError (String, String)
stripTag tag s = loop tag s "" 
    where --loop :: Tag -> String -> String -> ThrowsError (String, String)
          loop _ [] _ =  throwError BadMerengue
          loop Spill ('<':'/':'s':'p':'i':'l':'l':'>':xs) acc = return $ (acc,xs)
          loop Serve ('<':'/':'s':'e':'r':'v':'e':'>':xs) acc = return $ (acc,xs)
          loop t (x:xs) acc = loop t xs (acc ++ [x])